home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / usual.scm < prev   
Text File  |  1995-10-13  |  7KB  |  234 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file derive.scm.
  6.  
  7. ;;;; Macro expanders for the standard macros
  8.  
  9. (define the-usual-transforms (make-table))
  10.  
  11. (define (define-usual-macro name n proc aux-names)
  12.   (table-set! the-usual-transforms
  13.           name
  14.           (cons (lambda (exp rename compare)
  15.               (if (long-enough? (cdr exp) n)
  16.               (apply proc rename compare (cdr exp))
  17.               exp))
  18.             aux-names)))
  19.  
  20. (define (usual-transform name)
  21.   (or (table-ref the-usual-transforms name)
  22.       (call-error "no such transform" usual-transform name)))
  23.  
  24. (define (long-enough? l n)
  25.   (if (= n 0)
  26.       #t
  27.       (and (pair? l) (long-enough? (cdr l) (- n 1)))))
  28.  
  29. ;
  30.  
  31. (define-usual-macro 'and 0
  32.   (lambda (rename compare . conjuncts)
  33.     (cond ((null? conjuncts) `#t)
  34.           ((null? (cdr conjuncts)) (car conjuncts))
  35.           (else `(,(rename 'if) ,(car conjuncts)
  36.              (,(rename 'and) ,@(cdr conjuncts))
  37.              ,#f))))   ; bootstrapping does not allow #F embedded in
  38.                                ; quoted structure
  39.   '(if and))
  40.  
  41. ; Tortuously crafted so as to avoid dependency on any (unspecific)
  42. ; procedure.
  43.  
  44. (define-usual-macro 'cond 1
  45.   (lambda (rename compare . clauses)
  46.     (let ((result
  47.        (let recur ((clauses clauses))
  48.          (if (null? clauses)
  49.          '()
  50.          (list
  51.           (let ((clause (car clauses))
  52.             (more-clauses (cdr clauses)))
  53.             (cond ((not (pair? clause))
  54.                (syntax-error "invalid COND clause" clause))
  55.               ((and (null? more-clauses)
  56.                 (compare (car clause) (rename 'else)))
  57.                `(,(rename 'begin) ,@(cdr clause)))
  58.               ((null? (cdr clause))
  59.                `(,(rename 'or) ,(car clause)
  60.                        ,@(recur more-clauses)))
  61.               ((compare (cadr clause) (rename '=>))
  62.                (let ((temp (rename 'temp)))
  63.                  `(,(rename 'let)
  64.                    ((,temp ,(car clause)))
  65.                    (,(rename 'if) ,temp
  66.                           (,(caddr clause) ,temp)
  67.                           ,@(recur more-clauses)))))
  68.               (else
  69.                `(,(rename 'if) ,(car clause)
  70.                        (,(rename 'begin) ,@(cdr clause))
  71.                        ,@(recur more-clauses))))))))))
  72.       (if (null? result)
  73.       (syntax-error "empty COND")
  74.       (car result))))
  75.   '(or cond begin let if begin))
  76.  
  77. (define-usual-macro 'do 2
  78.   (lambda (rename compare . (specs end . body))
  79.     (let ((%loop (rename 'loop))
  80.       (%letrec (rename 'letrec))
  81.       (%lambda (rename 'lambda))
  82.       (%cond (rename 'cond)))
  83.       `(,%letrec ((,%loop
  84.            (,%lambda ,(map car specs)
  85.                  (,%cond ,end
  86.                      (else ,@body
  87.                        (,%loop
  88.                         ,@(map (lambda (y)
  89.                              (if (null? (cddr y))
  90.                              (car y)
  91.                              (caddr y)))
  92.                            specs)))))))
  93.          (,%loop ,@(map cadr specs)))))
  94.   '(letrec lambda cond))
  95.  
  96. (define-usual-macro 'let 2
  97.   (lambda (rename compare . (specs . body))
  98.     (cond ((list? specs)
  99.            `((,(rename 'lambda) ,(map car specs) ,@body)
  100.              ,@(map cadr specs)))
  101.           ((name? specs)
  102.            (let ((tag specs)
  103.                  (specs (car body))
  104.                  (body (cdr body))
  105.          (%letrec (rename 'letrec))
  106.          (%lambda (rename 'lambda)))
  107.              `(,%letrec ((,tag (,%lambda ,(map car specs) ,@body)))
  108.             (,tag ,@(map cadr specs)))))
  109.       (else (syntax-error "invalid LET syntax"
  110.                   `(let ,specs ,@body)))))
  111.   '(lambda letrec))
  112.  
  113. (define-usual-macro 'let* 2
  114.   (lambda (rename compare . (specs . body))
  115.     (if (or (null? specs)
  116.             (null? (cdr specs)))
  117.         `(,(rename 'let) ,specs ,@body)
  118.         `(,(rename 'let) (,(car specs))
  119.              (,(rename 'let*) ,(cdr specs) ,@body))))
  120.   '(let let*))
  121.  
  122. (define-usual-macro 'or 0
  123.   (lambda (rename compare . disjuncts)
  124.     (cond ((null? disjuncts) #f)  ;not '#f
  125.           ((null? (cdr disjuncts)) (car disjuncts))
  126.           (else (let ((temp (rename 'temp)))
  127.           `(,(rename 'let) ((,temp ,(car disjuncts)))
  128.              (,(rename 'if) ,temp
  129.              ,temp
  130.              (,(rename 'or) ,@(cdr disjuncts))))))))
  131.   '(let if or))
  132.  
  133.  
  134. ; CASE needs auxiliary MEMV.
  135.  
  136. (define-usual-macro 'case 2
  137.   (lambda (rename compare . (key . clauses))
  138.     (let ((temp (rename 'temp))
  139.       (%eqv? (rename 'eq?))
  140.       (%memv (rename 'memv))
  141.       (%quote (rename 'quote)))
  142.       `(,(rename 'let) ((,temp ,key))
  143.      (,(rename 'cond) ,@(map (lambda (clause)
  144.             `(,(cond ((compare (car clause) (rename 'else))
  145.                   (car clause))
  146.                  ((null? (car clause))
  147.                   #f)
  148.                  ((null? (cdar clause)) ;+++
  149.                   `(,%eqv? ,temp (,%quote ,(caar clause))))
  150.                  (else
  151.                   `(,%memv ,temp (,%quote ,(car clause)))))
  152.               ,@(cdr clause)))
  153.               clauses)))))
  154.   '(let cond eqv? memv quote))
  155.  
  156.  
  157. ; Quasiquote
  158.  
  159. (define-usual-macro 'quasiquote 1
  160.   (lambda (rename compare . (x))
  161.  
  162.     (define %quote (rename 'quote))
  163.     (define %quasiquote (rename 'quasiquote))
  164.     (define %unquote (rename 'unquote))
  165.     (define %unquote-splicing (rename 'unquote-splicing))
  166.     (define %append (rename 'append))
  167.     (define %cons (rename 'cons))
  168.     (define %list->vector (rename 'list->vector))
  169.  
  170.     (define (expand-quasiquote x level)
  171.       (descend-quasiquote x level finalize-quasiquote))
  172.  
  173.     (define (finalize-quasiquote mode arg)
  174.       (cond ((eq? mode 'quote) `(,%quote ,arg))
  175.         ((eq? mode 'unquote) arg)
  176.         ((eq? mode 'unquote-splicing)
  177.          (syntax-error ",@ in invalid context" arg))
  178.         (else `(,mode ,@arg))))
  179.  
  180.     (define (descend-quasiquote x level return)
  181.       (cond ((vector? x)
  182.          (descend-quasiquote-vector x level return))
  183.         ((not (pair? x))
  184.          (return 'quote x))
  185.         ((interesting-to-quasiquote? x %quasiquote)
  186.          (descend-quasiquote-pair x (+ level 1) return))
  187.         ((interesting-to-quasiquote? x %unquote)
  188.          (cond ((= level 0)
  189.             (return 'unquote (cadr x)))
  190.            (else
  191.             (descend-quasiquote-pair x (- level 1) return))))
  192.         ((interesting-to-quasiquote? x %unquote-splicing)
  193.          (cond ((= level 0)
  194.             (return 'unquote-splicing (cadr x)))
  195.            (else
  196.             (descend-quasiquote-pair x (- level 1) return))))
  197.         (else
  198.          (descend-quasiquote-pair x level return))))
  199.  
  200.     (define (descend-quasiquote-pair x level return)
  201.       (descend-quasiquote (car x) level
  202.     (lambda (car-mode car-arg)
  203.       (descend-quasiquote (cdr x) level
  204.         (lambda (cdr-mode cdr-arg)
  205.           (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
  206.              (return 'quote x))
  207.             ((eq? car-mode 'unquote-splicing)
  208.              ;; (,@mumble ...)
  209.              (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
  210.                 (return 'unquote
  211.                     car-arg))
  212.                (else
  213.                 (return %append
  214.                     (list car-arg (finalize-quasiquote
  215.                              cdr-mode cdr-arg))))))
  216.             (else
  217.              (return %cons
  218.                  (list (finalize-quasiquote car-mode car-arg)
  219.                    (finalize-quasiquote cdr-mode cdr-arg))))))))))
  220.  
  221.     (define (descend-quasiquote-vector x level return)
  222.       (descend-quasiquote (vector->list x) level
  223.     (lambda (mode arg)
  224.       (case mode
  225.         ((quote) (return 'quote x))
  226.         (else (return %list->vector
  227.               (list (finalize-quasiquote mode arg))))))))
  228.  
  229.     (define (interesting-to-quasiquote? x marker)
  230.       (and (pair? x) (compare (car x) marker)))
  231.  
  232.     (expand-quasiquote x 0))
  233.   '(append cons list->vector quasiquote unquote unquote-splicing))
  234.